home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tpb4_src.zip / UPLOAD.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-09-14  |  16.9 KB  |  520 lines
  1. { TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen  
  2.   Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault  
  3.   
  4.   Last modified  ::  9-10-88 11:01 am 
  5. }
  6.  
  7. {$R-}                             {Range checking off}
  8. {$B-}                             {Boolean complete evaluation off}
  9. {$S-}                             {Stack checking off}
  10. {$I+}                             {I/O checking on}
  11. {$N-}                             {No numeric coprocessor}
  12.  
  13. Unit Upload;
  14.  
  15. Interface
  16.  
  17. Uses
  18.   TPCrt, Dos, Globals, TPSTRING, TAccess,
  19.   TPDOS, Core1, Core2, Dirs, Sysop1;
  20.   
  21.   
  22. procedure RecvXmodem(mode : Char);
  23.  
  24.  
  25.   {==========================================================================}
  26.   
  27.   
  28. Implementation
  29.  
  30.  
  31.   procedure RecvXmodem(mode : Char);
  32.     { Receive a file using Xmodem protocol }
  33.     
  34.   var
  35.     filecount, i,
  36.     mm, ss          : Integer;
  37.     free            : LongInt;
  38.     Xfrname         : DosFileName;
  39.     Abort_batch,
  40.     In_Conference,
  41.     timeup          : Boolean;
  42.     bt              : Byte;
  43.     XfrFile         : untype_file;
  44.     TemDrv          : Str3;
  45.     TemName,
  46.     DszMode         : StrPr;
  47.     This            : SectPtr;
  48.     protocol_ok     : Boolean;
  49.     
  50.     
  51.     procedure Call_Dsz(var Xfrname     : DosFileName;
  52.                        var XfrFile     : untype_file;
  53.                        var mode        : Char);
  54.                        
  55.     begin                         {Call_Dsz}
  56.       Str(rate, baud);
  57.       OK := True;
  58.       errcode := 0;
  59.       SetSect(HomName);
  60.       Ch_Wait;
  61.       ScrollOn;
  62.       case mode of
  63.         'C' :
  64.           DszMode := 'rx';
  65.         'X' :
  66.           DszMode := 'rc';
  67.         'Y' :
  68.           DszMode := 'rc -k';
  69.         'Z' :
  70.           DszMode := 'rz -y';
  71.         'Q' :
  72.           DszMode := 'rc -g';
  73.         'O' :
  74.           DszMode := 'ro';
  75.       end;
  76.       errcode := ExecDos(DSZPath+' handshake on '+DszMode+' '+RcvName+'\'
  77.         +Xfrname, False, nil);
  78.       if errcode = 0 then errcode := DosExitCode;
  79.       Ch_Init;
  80.       Ch_Set(rate);
  81.       ScrollOff;
  82.       WriteLn(Com);
  83.       SetSect(RcvName);
  84.       Assign(XfrFile, Xfrname);
  85.       {$I-}
  86.       Reset(XfrFile) {$I+} ;      { Reopen file for return }
  87.       OK := (IoResult = 0);       { OK true if file found }
  88.       if OK then OK := (FileSize(XfrFile) > 0);
  89.       if (not Ch_Carck) then
  90.         begin
  91.           errcode := 1;
  92.           SetSect(HomName);
  93.           log(12, 'recving file');
  94.           SetSect(RcvName);
  95.           mdhangup;
  96.           remote_online := False;
  97.         end;
  98.       if errcode <> 0 then
  99.         OK := False;
  100.       if OK then
  101.         begin
  102.           WriteLn(Com);
  103.           WriteLn(Com, 'Transfer sucessfully completed.');
  104.         end;
  105.     end;                          {Call_Dsz}
  106.     
  107.     
  108.     
  109.     procedure Get_File(var Xfrname : DosFileName; mode : Char);
  110.     
  111.     var
  112.       block, mm, ss   : Integer;
  113.       i               : LongInt;
  114.       file_exists     : Boolean;
  115.       junk            : DosFileName;
  116.       
  117.     begin
  118.       if Xfrname <> '' then
  119.         begin
  120.           block := 1;
  121.           file_exists := False;
  122.           while (Length(Xfrname)-Pos('.', Xfrname)) < 2 do
  123.             Xfrname := Xfrname+'-';
  124.           SetSect(HomName);
  125.           case mode of
  126.             'Z' :
  127.               log(16, Xfrname);
  128.             'G' :
  129.               log(18, Xfrname)
  130.           else
  131.             log(4, Xfrname);
  132.           end;
  133.           junk := Xfrname;
  134.           FindKey(NewinName, i, junk); { Is it in the NEWIN file }
  135.           OK := (not OK);
  136.           if OK then              { No, so check upload area }
  137.             begin
  138.               SetSect(RcvName);
  139.               Assign(XfrFile, Xfrname);
  140.               {$I-}
  141.               Reset(XfrFile) {$I+} ; { Try to open file }
  142.               OK := (IoResult <> 0);
  143.             end;
  144.           if OK then              { Not in NEWIN file or upload area }
  145.             begin
  146.               {$I-}
  147.               Rewrite(XfrFile) {$I+} ; { Try to open file }
  148.               OK := (IoResult = 0);
  149.               if OK then
  150.                 begin
  151.                   Close(XfrFile);
  152.                   Erase(XfrFile);
  153.                   SetSect(HomName);
  154.                   free := (diskfree(Ord(Upcase(RcvDrv[1]))-64)) div 1024;
  155.                   WriteLn(Com);
  156.                   Write(Com, 'File:  ', Xfrname);
  157.                   if In_Conference then
  158.                     WriteLn(Com, ' will be received in this conference area.')
  159.                   else
  160.                     WriteLn(Com, ' will be received in a private area.');
  161.                   WriteLn(Com, free, 'k disk space available.');
  162.                   WriteLn(Com, 'Please cancel with Ctrl X''s if space is too small.');
  163.                   WriteLn(Com);
  164.                   WriteLn(Com, 'Ready to receive...');
  165.                   WriteLn(Com);
  166.                   SetSect(HomName);
  167.                   Call_Dsz(Xfrname, XfrFile, mode);
  168.                   if OK then
  169.                     OK := (FileSize(XfrFile) > 0);
  170.                   if OK then
  171.                     begin
  172.                       send_time(FileSize(XfrFile), mm, ss);
  173.                       extra_time := extra_time+mm+1;
  174.                     end;
  175.                   Close(XfrFile);
  176.                   if OK then
  177.                     begin
  178.                       if not In_Conference then
  179.                         hide_release(Xfrname, private, RcvName);
  180.                     end
  181.                   else
  182.                     begin
  183.                       Erase(XfrFile);
  184.                       WriteLn(Com);
  185.                       WriteLn(Com, 'Transfer cancelled.  Incomplete file deleted.');
  186.                     end;
  187.                 end
  188.               else
  189.                 WriteLn(Com, 'Cannot create ', Xfrname, '.');
  190.             end
  191.           else
  192.             begin
  193.               WriteLn(Com, 'Thanks, but there is already a copy of ', Xfrname,
  194.                 ' online.');
  195.               file_exists := True
  196.             end;
  197.           SetSect(HomName);
  198.           if OK then
  199.             log(7, '')
  200.           else
  201.             begin
  202.               if file_exists then
  203.                 log(8, 'File Exists')
  204.               else
  205.                 log(8, '');
  206.             end;
  207.         end;
  208.     end;
  209.     
  210.     
  211.     
  212.     procedure Get_description(Xfrname : DosFileName);
  213.     
  214.     var
  215.       work            : StrStd;
  216.       i               : Integer;
  217.       rec             : LongInt;
  218.       
  219.       function get_section(mode : Char)    : DosFileName;
  220.       
  221.       var
  222.         This            : SectPtr;
  223.         line_count,
  224.         conf_num        : Integer;
  225.         work            : DosFileName;
  226.         
  227.       begin
  228.         abort := False;
  229.         repeat
  230.           This := SectBase;
  231.           WriteLn(Com);
  232.           work := prompt('Section name ', 12, 'ES?M');
  233.           if work = ' ' then
  234.             begin
  235.               work := 'NEWIN';    {DEFAULT VALUE}
  236.               WriteLn(Com, 'Defaulting to: NEWIN');
  237.               WriteLn(Com);
  238.             end;
  239.           if work = '?' then
  240.             begin
  241.               line_count := 2;
  242.               WriteLn(Com, 'Available File Sections:');
  243.               WriteLn(Com);
  244.               while (not brk) and (This <> nil) do
  245.                 begin
  246.                   conf_num := This^.SectConf;
  247.                   if (user_rec.access >= This^.SectAccs) or (test_bit(user_rec.conf_flags,
  248.                     conf_num)) then
  249.                     begin
  250.                       Write(Com, yellow, pad(This^.SectName, 14));
  251.                       if mode = 'D' then
  252.                         WriteLn(Com, green, This^.SectDesc, cyan)
  253.                       else
  254.                         WriteLn(Com, cyan);
  255.                     end;
  256.                   This := This^.next;
  257.                   if user_rec.lines <> 99 then
  258.                     begin
  259.                       Inc(line_count);
  260.                       if line_count mod user_rec.lines = 0 then
  261.                         pause;
  262.                     end;
  263.                 end;
  264.               WriteLn(Com);
  265.             end;
  266.           This := SectBase;
  267.           while (This <> nil) and (This^.SectName <> work) do
  268.             This := This^.next;
  269.         until (work = This^.SectName) or (brk) or (not Online);
  270.         if work = This^.SectName then
  271.           get_section := work
  272.         else
  273.           get_section := 'NEWIN';
  274.       end;
  275.       
  276.     begin                         {get_description}
  277.       repeat
  278.         WriteLn(Com, white, 'Please enter a one line description of your file:');
  279.         WriteLn(Com);
  280.         WriteLn(Com, green,
  281.           '  |-------------------------------------------------------------------------|',
  282.           cyan);
  283.         work := prompt('', 75, 'EL');
  284.         WriteLn(Com);
  285.       until ((work <> '') and (ask('Is your description correct', 'Y'))) or (not Online);
  286.       WriteLn(Com, 'Enter Section Name where the file should be located.');
  287.       with nwin_rec do
  288.         begin
  289.           status := private;
  290.           PointValue := 0;
  291.           name := Xfrname;
  292.           GetTAD(date);
  293.           user := user_loc;
  294.           descr := work;
  295.           sectn := get_section('D');
  296.           dnloads := 0;
  297.           for i := 0 to 5 do
  298.             last_dnload[i] := 0;
  299.         end;
  300.       Seek(nwin_file, FileSize(nwin_file));
  301.       Write(nwin_file, nwin_rec);
  302.       rec := Pred(FileSize(nwin_file));
  303.       AddKey(NewinArea, rec, nwin_rec.sectn);
  304.       FlushIndex(NewinArea);
  305.       AddKey(NewinName, rec, nwin_rec.name);
  306.       FlushIndex(NewinName);
  307.     end;
  308.     
  309.   begin                           { RecvXmodem }
  310.     if (not(mode in ['G', 'Q'])) then
  311.       protocol_ok := True
  312.     else if (not AllowMNP) then
  313.       protocol_ok := False
  314.     else if cmd_tail and (StUpcase(ParamStr(3)) = 'MNP') then
  315.       protocol_ok := (ParamStr(4) = '/Arq')
  316.     else if cmd_tail then
  317.       protocol_ok := True
  318.     else
  319.       protocol_ok := mnp;
  320.     if ((diskfree(Ord(Upcase(RcvDrv[1]))-64) div 1024) > maxfree_uplds) and protocol_ok then
  321.       begin
  322.         filecount := 0;
  323.         Abort_batch := False;
  324.         Xfrname := ' ';           {set up}
  325.         In_Conference := False;
  326.         This := SectBase;
  327.         while (This <> nil) and (This^.SectName <> SectReq) do
  328.           This := This^.next;
  329.         if This^.SectName = SectReq then
  330.           begin
  331.             i := This^.SectConf;  {conference number}
  332.             In_Conference := test_bit(user_rec.conf_flags, i)
  333.           end;
  334.         if In_Conference then
  335.           begin
  336.             TemDrv := RcvDrv;
  337.             TemName := RcvName;
  338.             RcvDrv := SetDrv;
  339.             RcvName := SetName;
  340.           end;
  341.         if (mode in ['B', 'Z', 'G']) then
  342.           begin
  343.             case mode of
  344.               'Z' :
  345.                 log(16, Xfrname);
  346.               'G' :
  347.                 log(18, Xfrname)
  348.             else
  349.               log(4, Xfrname);
  350.             end;
  351.             free := (diskfree(Ord(Upcase(RcvDrv[1]))-64)) div 1024;
  352.             WriteLn(Com);
  353.             WriteLn(Com, 'Batch Mode Enabled -  ', free, 'K space available.');
  354.             WriteLn(Com, 'Please cancel with Ctrl X''s if space is too small.');
  355.             Write(Com, 'Files will be received in ');
  356.             if In_Conference then
  357.               WriteLn(Com, 'this conference area.')
  358.             else
  359.               WriteLn(Com, 'a private area.');
  360.             WriteLn(Com);
  361.             WriteLn(Com, white, 'Ready to Receive...');
  362.             WriteLn(Com, cyan);
  363.             Ch_Wait;
  364.             Delay(500);
  365.             Assign(ext_log, ZmdmLogName);
  366.             {$I-} ;
  367.             Reset(ext_log);
  368.             Close(ext_log);
  369.             {$I+} ;
  370.             if IoResult = 0 then
  371.               Erase(ext_log);
  372.             SetSect(RcvName);
  373.             Ch_Wait;
  374.             ScrollOn;
  375.             case mode of
  376.               'Z' :
  377.                 DszMode := 'rz';
  378.               'B' :
  379.                 DszMode := 'rb';
  380.               'G' :
  381.                 DszMode := 'rb -g';
  382.             end;
  383.             errcode := ExecDos(DSZPath+' handshake on restrict '+DszMode, False, nil);
  384.             SetSect(HomName);
  385.             Delay(1500);
  386.             Ch_Init;
  387.             Ch_Set(rate);
  388.             ScrollOff;
  389.             WriteLn(Com);
  390.             Abort_batch := True;
  391.             Assign(ext_log, ZmdmLogName);
  392.             {$I-}
  393.             Reset(ext_log) {$I+} ;
  394.             if IoResult = 0 then
  395.               begin
  396.                 while (not EoF(ext_log)) do
  397.                   begin
  398.                     ReadLn(ext_log, ext_log_rec);
  399.                     if (not(ext_log_rec[1] in ['E', 'L', 'U'])) then
  400.                       begin
  401.                         Abort_batch := False;
  402.                         Delete(ext_log_rec, 1, 50);
  403.                         if Pos(' ', ext_log_rec) <> 0 then
  404.                           Delete(ext_log_rec, Pos(' ', ext_log_rec), 10);
  405.                         Xfrname := ext_log_rec;
  406.                         for i := 1 to Length(Xfrname) do
  407.                           Xfrname[i] := Upcase(Xfrname[i]);
  408.                         WriteLn(Com, yellow, 'File: ', white, Xfrname, cyan);
  409.                         if Online then
  410.                           begin
  411.                             Get_description(Xfrname);
  412.                             SetSect(RcvName);
  413.                             Assign(XfrFile, Xfrname);
  414.                             {$I-}
  415.                             Reset(XfrFile) {$I+} ;
  416.                             OK := (IoResult = 0);
  417.                             if OK then
  418.                               begin
  419.                                 send_time(FileSize(XfrFile), mm, ss);
  420.                                 extra_time := extra_time+mm+1;
  421.                                 Close(XfrFile)
  422.                               end;
  423.                             SetSect(HomName);
  424.                           end;
  425.                         case mode of
  426.                           'Z' :
  427.                             log(16, Xfrname);
  428.                           'G' :
  429.                             log(18, Xfrname)
  430.                         else
  431.                           log(4, Xfrname);
  432.                         end;
  433.                         if not In_Conference then
  434.                           hide_release(Xfrname, private, RcvName);
  435.                       end;
  436.                   end;
  437.                 Close(ext_log);
  438.               end
  439.             else
  440.               begin
  441.                 Delay(1000);
  442.                 WriteLn(Com, 'Transfer aborted by sender or file already exits.')
  443.               end;
  444.             if (not Abort_batch) then
  445.               log(7, 'BATCH')
  446.             else
  447.               begin
  448.                 log(8, 'BATCH');
  449.                 WriteLn(Com, 'Aborting Zmodem Transfer.');
  450.               end;
  451.             if OK and (not Abort_batch) then
  452.               begin
  453.                 WriteLn(Com, 'Thanks, ', UserFirstName, '.');
  454.                 WriteLn(Com);
  455.                 WriteLn(Com, 'Your upload(s) will be credited when approved by the Sysop.');
  456.               end;
  457.             SetSect(HomName);
  458.             if (SetDrv = RcvDrv) and (SetName = RcvName) then
  459.               begin
  460.                 ReadDir(DirEntries, DirSpace, DirBase);
  461.                 new_dir := False;
  462.               end;
  463.           end                     {END OF BATCH}
  464.         else
  465.           begin
  466.             Xfrname := prompt('File name', 12, 'ES');
  467.             if Xfrname <> ' ' then
  468.               Xfrname := correct_fn(Xfrname)
  469.             else
  470.               Xfrname := '';
  471.             if Xfrname <> '' then
  472.               Get_File(Xfrname, mode);
  473.             if OK and (Xfrname <> '') then
  474.               begin
  475.                 WriteLn(Com);
  476.                 WriteLn(Com, 'Transfer Complete.');
  477.                 SetSect(HomName);
  478.                 Get_description(Xfrname);
  479.                 if (SetDrv = RcvDrv) and (SetName = RcvName) then
  480.                   begin
  481.                     ReadDir(DirEntries, DirSpace, DirBase);
  482.                     new_dir := False;
  483.                   end;
  484.                 WriteLn(Com, 'Thanks, ', UserFirstName, '.');
  485.                 WriteLn(Com, 'Your upload(s) will be credited when approved by the Sysop.');
  486.               end
  487.             else
  488.               Clear_inbuf;
  489.           end;
  490.         if In_Conference then
  491.           begin
  492.             RcvDrv := TemDrv;
  493.             RcvName := TemName;
  494.             In_Conference := False;
  495.           end;
  496.         SetSect(HomName);
  497.       end                         {got enough disk space}
  498.     else
  499.       begin
  500.         WriteLn(Com);
  501.         if (not protocol_ok) then
  502.           begin
  503.             WriteLn(Com, 'Sorry, that protocol requires an MNP connection.');
  504.             SetSect(HomName);
  505.             log(4, 'Not MNP');
  506.           end
  507.         else
  508.           WriteLn(Com, 'Not enough disk space for uploads.');
  509.         WriteLn(Com);
  510.       end;
  511.     repeat
  512.       bt := GetByte(2, timeup);
  513.     until timeup;
  514.   end;
  515.   
  516.   
  517. end.                              { of UPLOAD.PAS }
  518.  
  519. 
  520.